home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / iterate.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  63KB  |  1,270 lines
  1. ;;;-*- Package: ITERATE; Syntax: Common-Lisp; Base: 10 -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;; 
  27. ;;; Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33
  28.  
  29. (in-package :iterate :use '(:lisp :walker))
  30.    
  31.  
  32. (export '(iterate iterate* gathering gather with-gathering interval elements 
  33.                 list-elements list-tails plist-elements eachtime while until 
  34.                 collecting joining maximizing minimizing summing 
  35.                 *iterate-warnings*))
  36.  
  37. (defvar *iterate-warnings* :any "Controls whether warnings are issued for iterate/gather forms that aren't optimized.
  38. NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal."
  39.        )
  40.  
  41. ;;; ITERATE macro
  42.  
  43.  
  44. (defmacro iterate (clauses &body body &environment env)
  45.        (optimize-iterate-form clauses body env))
  46.  
  47. (defun
  48.  simple-expand-iterate-form
  49.  (clauses body)
  50.  
  51.  ;; Expand ITERATE.  This is the "formal semantics" expansion, which we never
  52.  ;; use.
  53.  (let*
  54.   ((block-name (gensym))
  55.    (bound-var-lists (mapcar #'(lambda (clause)
  56.                                      (let ((names (first clause)))
  57.                                           (if (listp names)
  58.                                               names
  59.                                               (list names))))
  60.                            clauses))
  61.    (generator-vars (mapcar #'(lambda (clause)
  62.                                     (declare (ignore clause))
  63.                                     (gensym))
  64.                           clauses)))
  65.   `(block ,block-name
  66.        (let*
  67.         ,(mapcan #'(lambda (gvar clause var-list)
  68.                                                ; For each clause, bind a
  69.                                                ; generator temp to the clause,
  70.                                                ; then bind the specified
  71.                                                ; var(s)
  72.                           (cons (list gvar (second clause))
  73.                                 (copy-list var-list)))
  74.                 generator-vars clauses bound-var-lists)
  75.         
  76.         ;; Note bug in formal semantics: there can be declarations in the head
  77.         ;; of BODY; they go here, rather than inside loop
  78.         (loop
  79.          ,@(mapcar
  80.             #'(lambda (var-list gen-var)
  81.                                                ; Set each bound variable (or
  82.                                                ; set of vars) to the result of
  83.                                                ; calling the corresponding
  84.                                                ; generator
  85.                      `(multiple-value-setq
  86.                        ,var-list
  87.                        (funcall ,gen-var #'(lambda nil (return-from
  88.                                                         ,block-name)))))
  89.             bound-var-lists generator-vars)
  90.          ,@body)))))
  91.  
  92. (defparameter *iterate-temp-vars-list*
  93.        '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 
  94.                iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8)
  95.        "Temp var names used by ITERATE expansions.")
  96.  
  97. (defun
  98.  optimize-iterate-form
  99.  (clauses body iterate-env)
  100.  (let*
  101.   ((temp-vars *iterate-temp-vars-list*)
  102.    (block-name (gensym))
  103.    (finish-form `(return-from ,block-name))
  104.    (bound-vars (mapcan #'(lambda (clause)
  105.                                 (let ((names (first clause)))
  106.                                      (if (listp names)
  107.                                          (copy-list names)
  108.                                          (list names))))
  109.                       clauses))
  110.    iterate-decls generator-decls update-forms bindings leftover-body)
  111.   (do ((tail bound-vars (cdr tail)))
  112.       ((null tail))
  113.                                                ; Check for duplicates
  114.     (when (member (car tail)
  115.                  (cdr tail))
  116.         (warn "Variable appears more than once in ITERATE: ~S" (car tail))))
  117.   (flet
  118.    ((get-iterate-temp nil 
  119.  
  120.            ;; Make temporary var.  Note that it is ok to re-use these symbols
  121.            ;; in each iterate, because they are not used within BODY.
  122.            (or (pop temp-vars)
  123.                (gensym))))
  124.    (dolist (clause clauses)
  125.        (cond
  126.         ((or (not (consp clause))
  127.              (not (consp (cdr clause))))
  128.          (warn "Bad syntax in ITERATE: clause not of form (var iterator): ~S" 
  129.                clause))
  130.         (t
  131.          (unless (null (cddr clause))
  132.                 (warn 
  133.        "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S"
  134.                       clause))
  135.          (multiple-value-bind
  136.           (let-body binding-type let-bindings localdecls otherdecls extra-body)
  137.           (expand-into-let (second clause)
  138.                  'iterate iterate-env)
  139.           
  140.           ;; We have expanded the generator clause and parsed it into its LET
  141.           ;; pieces.
  142.           (prog*
  143.            ((vars (first clause))
  144.             gen-args renamed-vars)
  145.            (setq vars (if (listp vars)
  146.                           (copy-list vars)
  147.                           (list vars)))
  148.                                                ; VARS is now a (fresh) list of
  149.                                                ; all iteration vars bound in
  150.                                                ; this clause
  151.            (cond
  152.             ((eq let-body :abort)
  153.                                                ; Already issued a warning
  154.                                                ; about malformedness
  155.              )
  156.             ((null (setq let-body (function-lambda-p let-body 1)))
  157.                                                ; Not of the expected form
  158.              (let ((generator (second clause)))
  159.                   (cond ((and (consp generator)
  160.                               (fboundp (car generator)))
  161.                                                ; It looks ok--a macro or
  162.                                                ; function here--so the guy who
  163.                                                ; wrote it just didn't do it in
  164.                                                ; an optimizable way
  165.                          (maybe-warn :definition "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
  166.                                 generator))
  167.                         (t                     ; Perhaps it's just a
  168.                                                ; misspelling?  Probably user
  169.                                                ; error
  170.                            (maybe-warn :user 
  171.                                 "Iterate operator in clause ~S is not fboundp."
  172.                                   generator)))
  173.                   (setq let-body :abort)))
  174.             (t
  175.              
  176.              ;; We have something of the form #'(LAMBDA (finisharg) ...),
  177.              ;; possibly with some LET bindings around it.  LET-BODY =
  178.              ;; ((finisharg) ...).
  179.              (setq let-body (cdr let-bod